perm filename PK.TYP[NEW,LCS] blob sn#561091 filedate 1981-02-01 generic text, type T, neo UTF8
00100		DIMENSION V(4000),Q(4000),R(128)
00200		EQUIVALENCE (JT,R(19)),(JF,R(18))
00300	C JF IS FLAG FOR NEW PACKING MODE (=-1 IF NEW, =>0 IF OLD)
00400	10	FORMAT(I)
00500	11	FORMAT(F13.3)
00600		CALL GETEXT('AAAAA','MS')
00700		CALL EXTIN(R,128)
00800		CALL EXTIN(V,JT)
00900		CALL PUTEXT('ZZZZZ','MS')
01000		I=0
01100		N=1
01200	1	J=V(N+1)
01250		L=V(N)
01300		NX=L+3+N
01400		LX=NX
01410	9	IF(L.LT.2)GO TO 12
01420		IF(V(LX-1).NE.0)GO TO 12
01430	C GET RID OF TRAILING ZERO PARAMS (AFTER P3)
01440		V(N)=V(N)-1
01450		LX=LX-1
01460		L=L-1
01470		GO TO 9
01500	12	CALL STUFIT(V,N,I)
01600	C MOVES N UP 4 COUNTS
01700		TYPE 10,V(I)
01750		GO TO 16
01775	C***** SKIP NEXT BECAUSE OF ROUND OFF ERRORS WHEN RETRIEVING.
01800		IF(J.EQ.16)GO TO 16
01820		IF(J.EQ.8)GO TO 16
01840		IF(J.EQ.11)GO TO 16
01900	C CATCH 'WORDS' AND PARAMS THAT MIGHT HAVE ASCII IN THEM.
02000		M=3
02100	3	IF(N.EQ.NX)GO TO 2
02200		M=M+1
02300	C UPDATE PARAM NUM.
02400		IF(V(N).NE.0)GO TO 4
02500	C SKIP ZERO PARAMS
02600	6	N=N+1
02700		GO TO 3
02800	4	I=I+1
02900	C UPDATE OUTPUT CNTR
03000		X=10000.0
03100		IF(V(N).LT.0)X=-X
03200		V(I)=V(N)+M*X
03300	C PUT PARAM NUMBER ON FRONT OF WD
03400		TYPE 11,V(I)
03500		GO TO 6
03600	16	IF(N.EQ.LX)GO TO 13
03620		DO 5 K=N,LX-1
03700		I=I+1
03800		TYPE 11,V(K)
03900	5	V(I)=V(K)
04000	13	N=NX
04100	2	IF(N.LT.JT)GO TO 1
04200		JT=I
04300	C DONE NOW
04400		CALL EXTOUT(R,128)
04500		CALL EXTOUT(V,I)
04600		CALL FINEXT
04700		PAUSE
04800	
04900	C NOW GET IT ALL BACK
05000	100	CALL GETEXT('ZZZZZ','MS')
05100		CALL EXTIN(R,128)
05200		CALL EXTIN(Q,JT)
05300		CALL PUTEXT('XXXXX','MS')
05400		I=0
05500		N=1
05700	20	CALL UNSTUF(Q,I,V,N)
05800		TYPE 11,V(N-4),V(N-3),V(N-2),V(N-1)
05900		J=V(N-3)
06000	C GET THE CODE NUM.
06100		NX=V(N-4)-1+N
06200	C HOW FAR DO WE GO FOR THIS ITEM?
06250		GO TO 36
06260	C***** SKIP NEXT BECAUSE OF ROUND OFF ERRORS WHEN RETRIEVING.
06300		IF(J.EQ.16)GO TO 36
06320		IF(J.EQ.8)GO TO 36
06340		IF(J.EQ.11)GO TO 36
06360		M=3
06380	22	IF(N.EQ.NX)GO TO 32
06390		M=M+1
06400		I=I+1
06500		L=Q(I)/10000.0
06600	C GET THE PARAM NUM.
06700		LL=IABS(L)
06900	24	IF(LL.EQ.M)GO TO 21
07000		IF(N.NE.NX)GO TO 25
07050		I=I-1
07075		GO TO 32
07100	25	V(N)=0
07200	C PUT BACK IN THE ZERO PARAMS.
07300		TYPE 11,V(N)
07350		M=M+1
07400	23	N=N+1
07500		GO TO 24
07600	21	X=Q(I)-L*10000
07700	C GET BACK THE REAL CONTENTS OF THE PARAM.
07900		V(N)=X
07925		TYPE 11,X
07950		N=N+1
08000		GO TO 22
08100	36	IF(N.EQ.NX)GO TO 32
08120		DO 35 K=N,NX-1
08200		I=I+1
08300		TYPE 11,Q(I)
08400	35	V(K)=Q(I)
08500		N=NX
08600	32	IF(I.LT.JT)GO TO 20
08700		JT=N
08800		CALL EXTOUT(R,128)
08900		CALL EXTOUT(V,N)
09000		CALL FINEXT
09100	
09200		END